(*
 * Redistribution and use in source and binary forms, with or without modification, are permitted 
 * provided that the following conditions are met:
 * 1.   Redistributions of source code must retain the above copyright notice, this list of 
 * conditions and the following disclaimer.
 * 2.   Redistributions in binary form must reproduce the above copyright notice, this list of
 * conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING,
 * BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY
 * OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
 * IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 *)

(*
 * Translation from ANormLazy.t to ANormStrict.t.
 *)
signature ANORM_LAZY_STRICTNESS =
sig
  val pass : (ANormLazy.t, ANormLazy.t) Pass.t
end

structure ANormLazyStrictness :> ANORM_LAZY_STRICTNESS =
struct
  structure I = Identifier
  structure L = Layout
  structure LU = LayoutUtils
  structure AL = ANormLazy
  structure AC = AbsCoreF (struct structure Dom = Pointed end) 
  structure LC = ANormLazyToAbsCoreF (struct structure AbsCore = AC end)
  structure AE = AbsCoreEvalF (struct structure AbsCore = AC end)
  structure ACL = AbsCoreLayoutF (struct structure AbsCore = AC 
                                         type ty = ANormLazy.ty
                                         val layoutTy = ANormLazyLayout.layoutTy
                                  end)
  structure ADL = AbsCoreLayoutF (struct structure AbsCore = AC 
                                         type ty = AE.demand
                                         val layoutTy = AE.layoutDemand
                                  end)

  val passname = "ANormLazyStrictness"

  fun setVars (st, vs) = 
      let
        fun setter (v, strict) =
            let
              val strict' = case I.variableInfo (st, v) of AE.L => false | _ => true
            in 
              (v, strict orelse strict')
            end
      in
        List.map (vs, setter)
      end

  fun setVars' (st, vs) = 
      let
        fun setter (v, ty, strict) =
            let
              val strict' = case I.variableInfo (st, v) of AE.L => false | _ => true
            in 
              (v, ty, strict orelse strict')
            end
      in
        List.map (vs, setter)
      end


  val rec doExp =
   fn (st, e) =>
      (case e
        of AL.ConApp (c, vs) => AL.ConApp (c, setVars (st, vs))
         | AL.App (e, v) => AL.App (doExp (st, e), v)
         | AL.Lam ((v, vty, _), e) => 
          let
            val strict = case I.variableInfo (st, v) of AE.L => false | _ => true
          in
            AL.Lam ((v, vty, strict), doExp (st, e)) 
          end
         | AL.Let (vdefg, e) => AL.Let (doVDefg (st, vdefg), doExp (st, e))
         | AL.Case (e, (v, vty), ty, alts) =>
          let
            val e = doExp (st, e)
            val doAlt = 
               fn AL.Acon (c, vs, e) => AL.Acon (c, setVars' (st, vs), doExp (st, e))
                | AL.Alit (l, t, e) => AL.Alit (l, t, doExp (st, e))
                | AL.Adefault e => AL.Adefault (doExp (st, e))
          in
            AL.Case (e, (v, vty), ty, List.map (alts, doAlt))
          end
         | AL.Cast (e, t1, t2) => AL.Cast (doExp (st, e), t1, t2)
         | e => e
      )

  and rec doVDef = 
   fn (st, vd) => 
      (case vd
        of AL.Vdef (AL.VbSingle (v, vty, _), e) => 
          let 
            val strict = case I.variableInfo (st, v) of AE.L => false | _ => true
          in
            AL.Vdef (AL.VbSingle (v, vty, strict), doExp (st, e))
          end
         | AL.Vdef (vs, e) => AL.Vdef (vs, doExp (st, e)))

  and rec doVDefg =
   fn (st, vdg) => 
      (case vdg
        of AL.Rec vdefs => AL.Rec (List.map (vdefs, fn def => doVDef (st, def)))
         | AL.Nonrec vdef => AL.Nonrec (doVDef (st, vdef)))

  val describe =
   fn () =>
      L.align [L.str (passname ^ " control string consists of:"),
               LU.indent (L.align [L.str "- => show AbsCore before strictness analysis",
                                   L.str "+ => show AbsCore after strictness analysis" ]),
               L.str "default is nothing"]

  type showOpt = { showBefore : bool, showAfter : bool }
  val defaultOpt = { showBefore = false, showAfter = false }

  val parse =
    fn s => 
      if s = "+" then SOME { showBefore = false, showAfter = true }
        else if s = "-" then SOME { showBefore = true, showAfter = false }
        else if s = "+-" orelse s = "-+" then SOME { showBefore = true, showAfter = true }
        else NONE

  val (control, showOptGet) = Config.Control.mk (passname, describe, parse, fn _ => defaultOpt)

  fun program (p as (AL.Module (main, vdefgs), im, tm), pd, bn) = 
      let
        val cfg = PassData.getConfig pd
        val opt = showOptGet cfg
        val (m, st) = LC.doModule p
        val ()  = if #showBefore opt then LU.printLayout (ACL.layout (cfg, st, m)) else ()
        val (m, st) = AE.annotate (m, st)
        val ()  = if #showAfter opt then LU.printLayout (ADL.layout (cfg, st, m)) else ()
        val vdefgs = List.map (vdefgs, fn vdefg => doVDefg (st, vdefg))
      in
        (AL.Module (main, vdefgs), im, tm)
      end
 
  fun layout (module, cfg) = ANormLazyLayout.layoutModule (cfg, module)

  val layout' = ANormLazyStats.layout (ANormLazyStats.O { id = SOME passname })

  val ir = { printer = layout, stater = layout' }

  val description = {name        = passname,
                     description = "Strictness Analysis on A-Normal Form",
                     inIr        = ir,
                     outIr       = ir,
                     mustBeAfter = [],
                     stats       = []}

  val associates = { controls = [control], debugs = [], features = [], subPasses = [] }

  val pass = Pass.mkOptFullPass (description, associates, program) 

end
